home *** CD-ROM | disk | FTP | other *** search
/ AmigActive 2 / AACD 2.iso / AACD / Programming / fpc / demos / bezier.pas < prev    next >
Pascal/Delphi Source File  |  1998-09-22  |  7KB  |  254 lines
  1. Program Bezier;
  2.  
  3. {
  4.    This program draws Bezier curves using the degree elevation
  5.    method.  For large numbers of points (more than 10, for
  6.    example) this is faster than the recursive way.
  7. }
  8.  
  9. {
  10.    Changed the source to use 2.0+.
  11.    Looks a lot better.
  12.    Added CloseWindowSafely.
  13.    Made the window dynamic, it will
  14.    adjust the size after the screen size.
  15.    9 May 1998.
  16.  
  17.    Translated the source to fpc.
  18.    20 Aug 1998.
  19.  
  20.    nils.sjoholm@mailbox.swipnet.se
  21. }
  22.  
  23. uses exec, intuition, graphics, utility;
  24.  
  25. {$I tagutils.inc}
  26.  
  27. type
  28.     PointRec = packed Record
  29.         X, Y : Real;
  30.     end;
  31.  
  32. Const
  33.     w  : pWindow  = Nil;
  34.     s  : pScreen   = Nil;
  35.     ltrue : longint = 1;
  36. {
  37.     This will make the new look for screen.
  38.     SA_Pens, Integer(pens)
  39. }
  40.     pens : array [0..0] of integer = (not 0);
  41.  
  42. Var
  43.     m  : pMessage;
  44.     rp : pRastPort;
  45.  
  46.     PointCount : Word;
  47.     Points : Array [1..200] of PointRec;
  48.  
  49.     t, tprime : Real;
  50.  
  51.     LastX, LastY : Word;
  52.     tags : array[0..13] of tTagItem;
  53.  
  54. Procedure CleanUpAndDie;
  55. begin
  56.     if w <> Nil then CloseWindow(w);
  57.     if s <> Nil then CloseScreen(s);
  58.     if Gfxbase <> nil then CloseLibrary(GfxBase);
  59.     Halt(0);
  60. end;
  61.  
  62. Procedure DrawLine;
  63. begin
  64.     Move(rp, Trunc(Points[PointCount].X), Trunc(Points[PointCount].Y));
  65.     Draw(rp, LastX, LastY);
  66. end;
  67.  
  68. Procedure GetPoints;
  69. var
  70.     LastSeconds,
  71.     LastMicros  : Longint;
  72.     IM : pIntuiMessage;
  73.     StoreMsg : tIntuiMessage;
  74.     Leave : Boolean;
  75.     OutOfBounds : Boolean;
  76.     BorderLeft, BorderRight,
  77.     BorderTop, BorderBottom : Word;
  78.     dummy : Boolean;
  79.  
  80.     Procedure AddPoint;
  81.     begin
  82.     Inc(PointCount);
  83.     with Points[PointCount] do begin
  84.         X := Real(StoreMsg.MouseX);
  85.         Y := Real(StoreMsg.MouseY);
  86.     end;
  87.     with StoreMsg do begin
  88.         LastX := MouseX;
  89.         LastY := MouseY;
  90.         LastSeconds := Seconds;
  91.         LastMicros := Micros;
  92.     end;
  93.     SetAPen(rp, 2);
  94.     SetDrMd(rp, JAM1);
  95.     DrawEllipse(rp, LastX, LastY, 5, 3);
  96.     SetAPen(rp, 3);
  97.     SetDrMd(rp, COMPLEMENT);
  98.     DrawLine;
  99.     end;
  100.  
  101.     Function CheckForExit : Boolean;
  102.     {   This function determines whether the user wanted to stop
  103.     entering points.  I added the position tests because my
  104.     doubleclick time is too long, and I was too lazy to dig
  105.     out Preferences to change it. }
  106.     begin
  107.     with StoreMsg do
  108.         CheckForExit := DoubleClick(LastSeconds, LastMicros,
  109.                     Seconds, Micros) and
  110.                 (Abs(MouseX - Trunc(Points[PointCount].X)) < 5) and
  111.                 (Abs(MouseY - TRunc(Points[PointCount].Y)) < 3);
  112.     end;
  113.  
  114.     Procedure ClearIt;
  115.     {  This just clears the screen when you enter your first point }
  116.     begin
  117.     SetDrMd(rp, JAM1);
  118.     SetAPen(rp, 0);
  119.     RectFill(rp, BorderLeft, BorderTop,
  120.              BorderRight, BorderBottom);
  121.     SetDrMd(rp, COMPLEMENT);
  122.     SetAPen(rp, 3);
  123.     end;
  124.  
  125. begin
  126.     dummy := ModifyIDCMP(w, IDCMP_CLOSEWINDOW or IDCMP_MOUSEBUTTONS or IDCMP_MOUSEMOVE);
  127.     SetDrMd(rp, COMPLEMENT);
  128.     PointCount := 0;
  129.     Leave := False;
  130.     OutOfBounds := False;
  131.     BorderLeft := w^.BorderLeft;
  132.     BorderRight := (w^.Width - w^.BorderRight) -1;
  133.     BorderTop := w^.BorderTop;
  134.     BorderBottom := (w^.Height - w^.BorderBottom) -1;
  135.     repeat
  136.         IM := pIntuiMessage(WaitPort(w^.UserPort));
  137.         IM := pIntuiMessage(GetMsg(w^.UserPort));
  138.         StoreMsg := IM^;
  139.         ReplyMsg(pMessage(IM));
  140.         case StoreMsg.IClass of
  141.            IDCMP_MOUSEMOVE : if PointCount > 0 then begin
  142.                  if not OutOfBounds then
  143.                  DrawLine;
  144.                      LastX := StoreMsg.MouseX;
  145.                      LastY := StoreMsg.MouseY;
  146.                  if (LastX > BorderLeft) and
  147.                 (LastX < BorderRight) and
  148.                 (LastY > BorderTop) and
  149.                 (LastY < BorderBottom) then begin
  150.                  DrawLine;
  151.                  OutOfBounds := False;
  152.                  end else
  153.                  OutOfBounds := True;
  154.                  end;
  155.            IDCMP_MOUSEBUTTONS : if StoreMsg.Code = SELECTUP then begin
  156.                     if PointCount > 0 then
  157.                     Leave := CheckForExit
  158.                 else
  159.                     ClearIt;
  160.                     if (not Leave) and (not OutOfBounds) then
  161.                     AddPoint;
  162.                     end;
  163.            IDCMP_CLOSEWINDOW : CleanUpAndDie;
  164.         end;
  165.     until Leave or (PointCount > 50);
  166.     if not Leave then
  167.         DrawLine;
  168.     dummy := ModifyIDCMP(w, IDCMP_CLOSEWINDOW);
  169.     SetDrMd(rp, JAM1);
  170.     SetAPen(rp, 1);
  171. end;
  172.  
  173. Procedure Elevate;
  174. var
  175.     t, tprime,
  176.     RealPoints : Real;
  177.     i : Integer;
  178. begin
  179.     Inc(PointCount);
  180.     RealPoints := Real(PointCount);
  181.     Points[PointCount] := Points[Pred(PointCount)];
  182.     for i := Pred(PointCount) downto 2 do
  183.     with Points[i] do begin
  184.         t := Real(i) / RealPoints;
  185.         tprime := 1.0 - t;
  186.         X := t * Points[Pred(i)].X + tprime * X;
  187.         Y := t * Points[Pred(i)].Y + tprime * Y;
  188.     end;
  189. end;
  190.  
  191. Procedure DrawCurve;
  192. var
  193.     i : Integer;
  194. begin
  195.     Move(rp, Trunc(Points[1].X), Trunc(Points[1].Y));
  196.     for i := 2 to PointCount do
  197.     Draw(rp, Round(Points[i].X), Round(Points[i].Y));
  198. end;
  199.  
  200. Procedure DrawBezier;
  201. var
  202.     i : Word;
  203. begin
  204.     SetAPen(rp, 2);
  205.     while PointCount < 100 do begin
  206.     Elevate;
  207.     DrawCurve;
  208.     if GetMsg(w^.UserPort) <> Nil then
  209.         CleanUpAndDie;
  210.     end;
  211.     SetAPen(rp, 1);
  212.     DrawCurve;
  213. end;
  214.  
  215. begin
  216.    GfxBase := OpenLibrary(GRAPHICSNAME,37);
  217.  
  218.                        tags[0] := TagItem(SA_Pens,      Long(@pens));
  219.                        tags[1] := TagItem(SA_Depth,     2);
  220.                        tags[2] := TagItem(SA_DisplayID, HIRES_KEY);
  221.                        tags[3] := TagItem(SA_Title,     Long(PChar('Simple Bezier Curves'#0)));
  222.                        tags[4].ti_Tag := TAG_END;
  223.     s := OpenScreenTagList(nil, @tags);
  224.     if s = NIL then CleanUpAndDie;
  225.  
  226.                         tags[0] := TagItem(WA_IDCMP,        IDCMP_CLOSEWINDOW);
  227.                         tags[1] := TagItem(WA_Left,         0);
  228.                         tags[2] := TagItem(WA_Top,          s^.BarHeight +1);
  229.                         tags[3] := TagItem(WA_Width,        s^.Width);
  230.                         tags[4] := TagItem(WA_Height,       s^.Height - (s^.BarHeight + 1));
  231.                         tags[5] := TagItem(WA_DepthGadget,  ltrue);
  232.                         tags[6] := TagItem(WA_DragBar,      ltrue);
  233.                         tags[7] := TagItem(WA_CloseGadget,  ltrue);
  234.                         tags[8] := TagItem(WA_ReportMouse,  ltrue);
  235.                         tags[9] := TagItem(WA_SmartRefresh, ltrue);
  236.                         tags[10] := TagItem(WA_Activate,     ltrue);
  237.                         tags[11] := TagItem(WA_Title,        long(PChar('Close the Window to Quit'#0)));
  238.                         tags[12] := TagItem(WA_CustomScreen, long(s));
  239.                         tags[13].ti_Tag := TAG_END;
  240.     w := OpenWindowTagList(nil, @tags);
  241.     IF w=NIL THEN CleanUpAndDie;
  242.  
  243.     rp := w^.RPort;
  244.     Move(rp, 252, 20);
  245.     Text(rp, PChar('Enter points by pressing the left mouse button'#0), 46);
  246.     Move(rp, 252, 30);
  247.     Text(rp, PChar('Double click on the last point to begin drawing'#0), 47);
  248.     repeat
  249.         GetPoints;  { Both these routines will quit if }
  250.         DrawBezier; { the window is closed. }
  251.     until False;
  252.     CleanUpAndDie;
  253. end.
  254.